;;#########################################################################
;; dataobj2.lsp
;; Copyright (c) 1991-2000 by Forrest W. Young
;;
;; SAVE-DATA   CREATE-DATA   DELETE-DATA   CURRENT-OBJECT-LINE  DATAFLOW-NAME  INFO
;; 
;;#########################################################################



(defmeth mv-data-object-proto :dataflow-name ()
  (let* ((namelist (parse-name (send self :proper-name))))
    (strcat "["
            (first namelist) 
            "." 
            (second namelist) 
            "#"
            (format nil "~a" (third namelist))
            "]"
            (send self :make-dataflow-path)
            )))

 
(defmeth mv-data-object-proto :make-data-flow-path ()
  (send self :make-dataflow-path))

(defmeth mv-data-object-proto :make-dataflow-path ()
    (let* ((pathsteps (fourth (parse-name (send self :proper-name))))
           (path ))
      (mapcar #'(lambda (step) 
                  (setf path (strcat path "»" step ))
                  )
              pathsteps)
      (send self :dataflow-path path)
      path))


(defmeth mv-data-object-proto :info (&optional (stream *standard-output*)
                                               &key (verbose nil) (subject nil))
  (if (or *history* verbose)
      (unless (equal (string-downcase (send self :name)) "hidden")
              (format stream  "~%; ~a: Name:      ~a~%" 
                      (if subject subject "Object") 
                      (send self :proper-name))
;fwy changed following 10-13-02
               (format stream  ";         DataFile:  ~a~%" 
                       (if (send self :datafile)
                          (send self :datafile) 
                          "[Not Saved To File]"))
              ;(format stream  ";         DataFile:  ~a~%" 
              ;        (if (not (send self :datafile))
              ;            (send self :datafile
              ;                  (send *workmap* :datafile))
              ;            (if (send self :datafile)
              ;                (send self :datafile) 
              ;                "[Not Saved To File]")))
              (format stream  ";         StatObjct:  ~a~%" (send self :make-vistatype))
              (format stream  ";         ProtoType: ~a~%" 
                      (string-capitalize 
                       (send self :slot-value 'proto-name)))
              (format stream  ";         Address:   ~d~%" (address-of self))
              (format stream  ";         Created:   ~a~%" 
                      (send self :slot-value 'instance-info))
              (format stream  ";         Elapsed:   ~,4d seconds~%" 
                      (fuzz (send self :elapsed-time) 3)))
        (format stream "; Data:   ~a; ~a; ~,4d seconds~%> "
              (send self :proper-name) (send self :vistatype) 
                (fuzz (send self :elapsed-time) 3)))
  )
                 


(defmeth mv-data-object-proto :current-object-line ()
  (unless (boundp '*current-object-info-line*) 
                   (make-current-object-info-line))
  (send *workmap* ::current-object-info-line 
        (if (send $ :datafile)
            (list (send $ :datafile) (send $ :dataflow-name))
            (send $ :dataflow-name))))


(defmeth mv-data-object-proto :current-object-line ())

(defmeth mv-data-object-proto :add-parent (parent-object)
  (send self :dob-parents 
      (add-element-to-list (send self :dob-parents) parent-object)))

(defmeth mv-data-object-proto :add-child (child-object)
  (send self :dob-children 
        (add-element-to-list (send self :dob-children) child-object)))
        
;(trace :save-data)


;;---------------------------------------------------------------------------
;; SAVE DATA
;;---------------------------------------------------------------------------


(defmeth mv-data-object-proto :save-data  (&optional file dont-save closing hidden dashobj)
"Args: (&optional file dont-save closing hidden dashobj )
FILE is a string. The data are obtained from datasheet DASHOBJ, or, if not specified, the datasheet used by *CURRENT-DATA*, if there it has one, or from *current-data*. If the datasheet is open, editable, and edited, the datasheet is saved so that the dataobject is updated (if the dataobject has family, a new dataobject is created). Then, unless DONT-SAVE is T, the updated or new data-object is written to FILE.lsp in a form suitable for use with the open-data command. CLOSING is t when datasheet being closed as well." 
  (let* ((closed t)
         (dsob (if dashobj dashobj (send *current-data* :datasheet-object)))
         (initial (if dsob (send dsob :initial) nil))
         ;(initial (send (send self :datasheet-object) :initial))
         (prompt-name (if (send self :name) (strcat (send self :name) ".lsp") nil))
         (iconname)
         )
    (when dsob (send dsob :error-check))
    (when (not dont-save)
          (if (not (set-working-directory *user-dir-name*))
           (set-working-directory "C:\\windows\\desktop"))
          (when (not file) 
                ;(send *workmap* :start-buffering)
                (setf file
#+macintosh           (clean-set-file-dialog "Save Data As DataFile:" prompt-name t)
#+msdos               (clean-set-file-dialog "Save (or Export) Data As:" (send self :name)
                                             "Save Data As ViSta DataFile (*.VDF)|*.vdf|Save Data As ViStaSourceFile (*.VIS)|*.vis|Save Data As LispSourceFile (*.LSP)|*.lsp|Export Data As Space-Delimited Text (*.TXT)|*.txt|Save Data As ... (*.*)|*.*")
#+X11                 (if file (file-save-dialog "Save Data As DataFile..." "*.lsp" "." file )
                          (file-save-dialog "Save Data as DataFile..." "*.lsp" "."))
                      )
                ;(send *workmap* :buffer-to-screen)
                )
          ) 
    (cond
      ((equal (pathname-type file) "txt")
       (send self :export-data file))
      (t
       (when file
             (when (and (> (length file) 3)
                        (string= ".lsp" file :start2 (- (length file) 4)))
                   (setf file (string-right-trim "lsp" file))
                   (setf file (string-right-trim "." file)))
             (setf iconname 
                   (reverse (subseq (reverse file) 0 (position #\\ (reverse file))))))
       (unless hidden
               (if initial
                   ;(send (send self :datasheet-object) 
                          ;      :save-datasheet t nil 0 iconname initial); t closing
                   (send dsob :save-datasheet t nil 0 iconname initial); t closing
                   (send self :update-data)))
       (when (and (equal (send self :data-type) "missing")
                  (equal (send self :real-data-type) "new"))
             (send self :determine-data-type)
             (send *desktop-datasheet* :title 
                   (strcat "DataSheet - " (send self :name) " (DataType: " (send self :data-type)")"))
             )
       (when (and file (not dont-save))
             (when closed
                   (unless hidden
                           (when dsob (send dsob :save-datasheet-arguments))
                           (when (and *datasheet* (not (equal dsob *datasheet*)))
                                 (send *datasheet* :save-datasheet-arguments)))
                   (setf file (string-downcase-if-not-X11 file))
                (send self :datafile  (strcat file ".lsp"))
                   ;(strcat (get-working-directory) file ".lsp")
                   (let* ((f (open (strcat (string file) ".lsp") 
                                   :direction :output))
                          (oldbreak *breakenable*))
                     (setq *breakenable* nil)
                     ; (send *current-data* :save-data-template f)
                     (send self :save-data-template f)
                     (setq *breakenable* oldbreak)
                     (close f)
                     (format t "; ToFile: DataFile: ~a~%> ; Saved:  ~a~%" 
                             (send self :datafile)(send self :full-name))
                     f)
                   ))))))
    
    
(defmeth mv-data-object-proto :save-data-template (f)
  (unwind-protect
   (print 
    `(data       ,(send self   :name)
                 :title        ,(send self :title)
                 :about        ,(send self :about)
                 :freq         ,(send self :freq)
                 :row-label    ,(first (send self :freq-way-names))
                 :column-label ,(second (send self :freq-way-names))
                 :array        ,(send self :array)
                 :variables   ',(send self :active-variables '(all))
                 :types       ',(send self :active-types '(all))
                 :labels      ',(send self :active-labels)
                 :data        ',(send self :active-data '(all))
                 :datasheet-arguments ',(send self :datasheet-arguments)
                 )
    f)))


;;---------------------------------------------------------------------------
;; DELETE DATA
;;---------------------------------------------------------------------------


(defmeth mv-data-object-proto :delete-data ()
"Message args: none
Deletes a data object and all its child objects."
  (send *workmap* :delete-data))



;;---------------------------------------------------------------------------
;; CREATE-CONVERT DATA
;; menu sends (send *current-data* :create-data) message
;;---------------------------------------------------------------------------

                             
           
(defmeth mv-data-object-proto :create-data
  (&optional name &key (table nil) (array-now nil) (hidden nil hidden?) (iconify t iconify?) (convert t) (known-as)(buffer nil) (creator t))
"Message args: (&optional name &key (table nil) (array-now nil) (hidden nil hidden?) (iconify t iconify?) (convert t) (known-as)(buffer nil))
Creates a new data object from the current active data.  Can optionally remove rows of multivariate data that have missing values, or convert between frequency data types. If NAME is specified, the data object is named NAME (a string). If NAME not specified a dialog is presented for name. KNOWN-AS specifies a pseudonym. Computation of array information postponed unless ARRAY-NOW T. Returns object identification of the new data object. Dataobject iconified unless ICONIFY is NIL (T by default). Dataobject iconified as datasheet if ICONIFY is \"datasheet\", and as data object if T. Buffer dataobject created when buffer is T. CONVERT is used to prevent any conversions when creating buffer for datasheet or simply copying."
  (if (not (eq current-object self)) (setcd self))
  (setf merge-dob nil)
  (let* ((result nil)
         (selection (send self :current-selected-labels))
         (pt-state (send self :point-state selection))
         (pt-color (send self :point-color selection))
         (pt-symbol (send self :point-symbol selection))
         (types (send self :active-types '(all)))
         (type-types (remove-duplicates types :test #'equal))
         (data-type (send self :data-type))
         (rest-types (rest type-types))
         (all-variables (send self :active-variables '(all))) 
         (cat-variables (send self :active-variables '(category)))
         (totalfreq)
         (ncat)
         (dataout (send self :active-selected-data '(all)))
         (labelsout (send self :active-selected-labels))
         (returned nil)
         (new-dob)
         (nemo)
         (creator (if creator (send *desktop* :selected-icon) nil))
         (title (if creator (strcat "Created from: " (send self :title)) (send self :title)))
         (iconify (cond 
                    ((and hidden? iconify?)
                     (error "cannot use both hidden and iconify"))
                    (hidden? (setf iconify? t)
                             (not hidden))
                    (iconify? iconify)
                    (t)))
         (create-new-mv-data nil)
         (prev-data-str "The previous data were described as:")
         )
    (setf *show-info* (if (equal iconify "datasheet") nil t))
    ;changed 728 5.6 to eliminate  computing array and then removing rows
    (when (and (not (equal data-type "missing"))(send self :array))
          (setf totalfreq (sum (combine (send self :active-freq-array))))
          (setf ncat (length cat-variables)))
    (when (not name)
          (setf nemo t)
          (setf name (send self :name)))
    ;(one-button-dialog (format nil "~a" (list data-type)))
    (cond 
      ;MISSING data
      ((equal data-type "missing")
       (setf create-new-mv-data t)
       ;convert added to prevent any conversions when creating buffer 
       ;for datasheet.  the datasheet will always receive unconverted data.
       (when (and convert (two-button-dialog
              (format nil "Remove Rows with Missing~%Numeric or Ordinal Data?") 
              :first-button "Remove" :second-button "Keep"))
             (setf returned (remove-missing-data-rows
                             (send self :active-data-matrix '(all))
                             :labels labelsout))
             (setf dataout (combine (first returned)))
             (setf labelsout (second returned))
             (when (not (first dataout)) 
                   (fatal-message "All rows contain missing values. New data not created."))
             (setf new-name (send self :get-new-data-name
                                  name (strcat "NoMis_!" (send self :name))))
             (setf new-dob
                   (data new-name
                         :created (if creator (send *desktop* :selected-icon) nil)
                         :title title
                         :about (format nil "Created from ~a, which had rows with missing values that were removed. ~a ~2%~a" (send self :name) prev-data-str (send self :about))
                         :data dataout
                         :variables all-variables
                         :labels labelsout
                         :types types
                         :iconify iconify
                         :known-as known-as
                         :buffer buffer))
             (setf create-new-mv-data nil)))
      
;CATEGORY data - subsets correctly
      ((or (equal (send self :data-type) "category")
           (and (= (length type-types) 1)
                (equal (string-downcase (first type-types)) "category")))
       (cond
         ((or (not convert) (= 1 ncat))
          (setf returned (list 1 (send self :get-new-data-name 
                                      (if nemo nil name)
                                      (strcat "CC!" (send self :name))))))
         (t
          (setf returned (send (send self :create-data-dialog 
                                     (strcat "CC!" name) ncat)
                               :modal-dialog))))
       (when nemo (setf name (second returned)))
       (case (first returned)
         (0 (setf new-dob
                  (send self :create-freqclass-data 
                        name 
                        (send self :active-variables '(category))
                        iconify known-as buffer creator)))
         (1 (setf create-new-mv-data t)) 

         (2 (setf new-dob
                  (send self :CREATE-FREQTABLE-DATA name cat-variables iconify
                        known-as buffer creator)))
         )
       )

;FREQ TABLE data
      ;note table data can have both categ and numeric variables 
      ;and can thus be data-type multivariate,
      ;but they can have data which are frequencies, as indicated by the freq flag
      ((or (equal data-type "freq")
           (and (send self :freq) (equal data-type "multivariate")))
       (setf returned (if convert
                          (send (send self :create-data-dialog name ncat) :modal-dialog)
                          (list 2 (strcat "CC!" name))))
       (when nemo (setf name (second returned)))
       (setf new-dob
             (case (first returned)
               (0 (send self :create-freqclass-data 
                        name 
                        (send self :freq-way-names)
                        iconify known-as buffer creator))   ;ng subsetting both vars obs    
               (1 (send self :convert-freq-to-category-data-object))
               (2 (send self :COPY-FREQTABLE-DATA name  
                        (send self :freq-way-names)
                        (send self :active-variables '(all)) 
                        (send self :active-labels)
                        (send self :active-data '(all))
                        iconify known-as buffer creator))
               ))
       )

;FREQ CLASS DATA
      ((or (equal data-type "freqclass")
           (and (equal data-type "class")(send self :freq)))
       (setf returned 
             (if convert
                 (send (send self :create-data-dialog name ncat) :modal-dialog)
                 (list 0 name)))
       (when nemo (setf name (second returned)))
       (case (first returned)
         (0 (setf create-new-mv-data t)) ;subsets OK
         (1 (setf new-dob  (send self :convert-freqclass2cat-dob name)))
         (2 (setf new-dob  (send self :CREATE-FREQTABLE-DATA 
                                 name cat-variables iconify known-as buffer creator)))))
     
;CLASS DATA
      ((equal data-type "class")
       (setf create-new-mv-data t)
       (setf name (send self :get-new-data-name 
                        (if nemo nil name)
                        (strcat "CC!" (send self :name)))))

;GENERAL
      ((or (equal data-type "crosstabs")
           (equal data-type "general"))
       (setf create-new-mv-data t)
       (setf name (send self :get-new-data-name 
                        (if nemo nil name)
                        (strcat "CC!" (send self :name)))))

;MULTIVARIATE
      ((equal data-type "multivariate")
       (setf create-new-mv-data t)
       (setf name (send self :get-new-data-name 
                        (if nemo nil name)
                        (strcat "CC!" (send self :name)))))

;MAATRIX data delt with elsewhere
;TABLE data not recognized.
      (t
       (fatal-message "Unknown Data Type"))
      )
    ;need to create new data
    (when create-new-mv-data
          (setf new-dob
                (data name
                      :title title
                      :about (if creator
                                 (format nil "Created by Create|Convert from previous data named ~a. ~a~2%" 
                                     (send self :name) prev-data-str 
                                     (send self :about))
                                 (send self :about))
                      :created creator
                      :data dataout
                      :variables all-variables
                      :labels labelsout
                      :types types
                      :iconify iconify
                      :known-as known-as
                      :buffer buffer))
          (send new-dob :record-linking-info)
          (send new-dob :point-color (iseq (length selection)) pt-color)
          (send new-dob :point-symbol (iseq (length selection)) pt-symbol)
          (send new-dob :point-state (iseq (length selection)) pt-state)
          (send *vista* :show-obs)
          )
    (send self :point-color selection pt-color)
    (send self :point-symbol selection pt-symbol)
    (send self :point-state selection pt-state)
    
    (setf *show-info* nil)
    new-dob))


(defmeth mv-data-object-proto :make-labels-from-cat-matrix (string-matrix)
"Args: String-Matrix
Makes labels from the category values in matrix. 
Assumes string-matrix only contains strings."
  (mapcar #'(lambda (str-vector)
              (let ((str-list (coerce str-vector 'list))
                    (str)
                    (shtstr))
                (dotimes (i (length str-list))
                         (setf shtstr (select str-list i))
                         (setf L (min 8 (length shtstr)))
                         (setf shtstr (select shtstr (iseq L)))
                         (if (= i 0)
                             (setf str shtstr)
                             (setf str (strcat str "*" shtstr))))
                str))
          (row-list string-matrix)))

(defmeth mv-data-object-proto :create-freqclass-data 
  (name cat-var-names &optional iconify known-as buffer creator)
  (let* ((new-name 
          (if name name
              (send self :get-new-data-name name
                    (strcat "FrqCls-" (send self :name)))))
         (new-variables (combine "Frequency" cat-var-names))
         (ncatvar (length cat-var-names))
         (prev-data-str "The previous data were described as:")
         (new-about
          (format nil 
 "~d-Way frequency classification created from the ~d category variables in ~a. ~a~2%~a" 
                  ncatvar ncatvar (send self :name) 
                  prev-data-str (send self :about)))
         (results (send self :convert-array2freqclass))
         (sizes (array-dimensions results))
         (cat-mat (select results (iseq (first sizes)) (iseq 1  (1- (second sizes)))))
         (labels (send self :make-labels-from-cat-matrix cat-mat))
         )
    (data new-name
          :freq t
          :array t
          :about new-about
          :created (if creator (send *desktop* :selected-icon) nil)
          :variables new-variables
          :labels labels
          :types (combine "Numeric" (repeat "category" ncatvar))
          :iconify iconify
          :known-as known-as
          :buffer buffer
          :data (combine (send self :convert-array2freqclass)))
    ))


(defmeth mv-data-object-proto :COPY-freqtable-data 
  (name row-col-labels table-variables table-labels data iconify known-as buffer creator)
  (let* ((new-name 
          (if name name
              (send self :get-new-data-name name
                    (strcat "CC!" (send self :name)))))
         (new-about (strcat "Two-Way frequency table copied from two-way frequency table. The previous data were described as:" (send self :about)))
         )
        (data new-name
              :freq t
              :array t
              :row-label (first row-col-labels)
              :column-label (second row-col-labels)
              :about new-about
              :created (if creator (send *desktop* :selected-icon) nil)
              :variables table-variables
              :labels table-labels
              :iconify iconify
              :known-as known-as
              :buffer buffer
              :data data)
    ))

(defmeth mv-data-object-proto :create-freqtable-data 
  (name cat-var-names &optional ;row-col-labels table-variables table-labels data 
        iconify known-as buffer creator)
  (let* ((new-name 
          (if name name
              (send self :get-new-data-name name
                    (strcat "CC!" (send self :name)))))
         (prev-data-str "The previous data were described as:")
         (new-about
          (format nil 
 "Two-Way frequency table created from ~a in ~a. ~a~2%~a" 
                  (if cat-var-names
                      "two category variables in"
                      "frequency table")
                  (send self :name) 
                  prev-data-str (send self :about)))
         (result (if cat-var-names
                     (send self :convert-array2freqclass)
                     nil))
         )
    (if cat-var-names
        (data new-name
              :freq t
              :row-label (first cat-var-names)
              :column-label (second cat-var-names)
              :about new-about
              :created (if creator (send *desktop* :selected-icon) nil)
              :variables (second (send self :array-labels))
              :labels (first (send self :array-labels))
              :iconify iconify
              :known-as known-as
              :buffer buffer
              :data (combine (col result 0)))
        (data new-name
              :freq t
              :array t
              :row-label (first row-col-labels)
              :column-label (second row-col-labels)
              :about new-about
              :created (if creator (send *desktop* :selected-icon) nil)
              :variables table-variables
              :labels table-labels
              :iconify iconify
              :known-as known-as
              :buffer buffer
              :data data))
    ))

;fwy 12182000
(defmeth mv-data-object-proto :create-data-dialog (name ncatvar)
  (let* ((dob self)
         (indatatype (send dob :data-type))
         (totalfreq (sum (combine (send self :active-freq-array))))
         (freqclass-str "FREQUENCY CLASSIFICATION Data")
         (category-str (format nil "CATEGORY Data (~d observations)" 
                                        (fuzz totalfreq 0)))
         (freqtable-str "FREQUENCY TABLE data")
         (dialog-text 
          (send text-item-proto :new 
                (format nil "CONVERT THESE FREQUENCY DATA TO ANOTHER TYPE:~%~%These data are~%~a.~%They can be converted.~%~%CONVERT THESE DATA TO:"
                        (cond
                          ((equal indatatype "freq") freqtable-str)
                          ((equal indatatype "category") category-str)
                          (t freqclass-str)))))
         (name-text-item  (send text-item-proto :new "NAME OF NEW DATA OBJECT:"))
         (name-item (send edit-text-item-proto :new (strcat "CC!" name)))
         (choice-text (if (< totalfreq 5001)
                          (list "Frequency Classification Data"
                                (format nil "Category Data (~d observations)" 
                                        (fuzz totalfreq 0)))
                          (list "Frequency Classification Data")))
         (choice-text (if (or (= ncatvar 2)
                              (equal (send self :data-type) "freq"))
                          (combine choice-text "Frequency Table Data")
                          choice-text))
         (choice-item (send choice-item-proto :new choice-text
              :action #'(lambda ()
                  (send name-item :text 
                        (send dob :suggested-name name)))))
         (string (when (> totalfreq 5000)
                       (format nil "NOTE:~%Frequency Category Data Impossible:~%Frequency (~a) Too High"
                               totalfreq)))
         (warning-text (if string (send text-item-proto :new string)))
         (ok        (send modal-button-proto :new "OK"
                          :action #'(lambda ()
                                      (let* ((result (send choice-item :value)))
                                        (if (and (> totalfreq 5000) (= result 1) ) 
                                            (setf result 2))
                                        (list result (send name-item :text))))))
         (cancel    (send modal-button-proto :new "Cancel"))
         (dialog-items (remove 'nil (list dialog-text
                                          choice-item
                                          ;name-text-item 
                                          ;name-item
                                          (list OK cancel)
                                          (if (> totalfreq 5000) string))))
         )
    (defmeth dob :suggested-name (name)
      (strcat (case (send choice-item :value)
                (0 "CC!") (1 "CC!") (2 "CC!")) name))
    (send modal-dialog-proto :new dialog-items
          :title "Convert Data Dialog"
                           :default-button OK)))
    


                          
          
;multivariate category data or array data


(defmeth mv-data-object-proto :close-dialog (table)
"Gets name of new data object and whether it is to be a table or not."
  (list (get-string-dialog 
         "Name of the New Data Object:"
         :initial (strcat "Cre!" (send self :name))) nil))


(defmeth mv-data-object-proto :update-data (&optional save-to-file)
  (when (send *desktop-datasheet* :edited)
        (send *desktop-datasheet* :save-datasheet save-to-file)
        (send *desktop-datasheet* :edited nil))
  )


(defmeth mv-data-object-proto :get-new-data-name (name suggested-name)
  (when (not name) 
        (cond
          ((not suggested-name)
           (setf name (get-string-dialog "Name of New Data Object:"))
           (when (or (not name) (equal name ""))
                 (fatal-message "You must enter a name")))
          (t
           (setf name suggested-name))))
  name)



(provide "dataobj2")